perm filename DRAWSM.F4[MSS,LCS]3 blob sn#103210 filedate 1974-05-21 generic text, type T, neo UTF8
00100		SUBROUTINE DRAWIT
00200		COMMON/ED/K,NEXT,NN,NX,NY,J
00300		COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400		COMMON /RC/MCLEF(400),IST(4000)
00500		COMMON/ZN/SCLEF(400,2),DDD
00600		COMMON/LL/LL
00610		COMMON/JJJ/JJJ
00620		DIMENSION ITEM(20)
00700		EQUIVALENCE(MM,SCLEF(1,1)),(W,IST(4000))
00800		DATA RN/15./
00900	CC	CALL ACCPOG(1)
01000	C  DISPLAYS OLD ITEM WITHOUT FILLER
01100	CC	CALL DPYOUT(1)
01200		REL=-1
01300		JC=0
01500		KE=-1
01600		JCL=0
01700		RJ=1
01900		IF(MM.EQ.0)GO TO 20
02000		J=MM
02100		JX=-1
02200		JCL=MM
02300		NX=SCLEF(MM,1)
02400		NY=SCLEF(MM,2)
02500		GO TO 120
02600	CC20	IF(JF.EQ.0)J=1
02900	20	J=1
03000		JZ=J
03200	2	NX=RJB*RSZ
03300		NY=CENTR*RSZ
03500	121	JX=0
03600	120	NZ=-1
03700		JC=1
03800		RL=NX
03900		RM=NY
04000	C  L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
04100	44	CALL SETCUR(NX,NY,0)
04200	83	S=0
04300	4	IF(S)GO TO 81
04320		IF(K.EQ.'E')GO TO 700
04360	C  BYPASS FOR EDITING.
04380	45	FORMAT(' <CR> SETS POINT ',$)
04400		TYPE 45
04500		ACCEPT 144,K,ZK,KK
04600		IF(ZK.NE.'E')GO TO 344
04700		REL=0
04800	C  TYPE REL FOR RELATIVE VECTORS, O=ORDINARY
04900		GO TO 4
05000	344	IF(K.NE.'O')GO TO 244
05100		REL=-1
05200		GO TO 4
05300	144	FORMAT(3A1)
05315	244	IF(ZK.NE.'M')GO TO 444
05316	C  TYPE SM TO SMOOTH, SMX=ERASE STRAIGHT LINES TEMPORARILY.
05317		MCLEF(1)=J
05318		CALL SMOOTH(KK)
05319		GO TO 4
05320	444	IF(ZK.NE.'X')GO TO 445
05330		MCLEF(2)=MCLEF(2)+200000000
05335		K='X'
05340		GO TO 3
05400	445	REREAD 1,K,ZK,XK
05500		IF(K.LE.' ')GO TO 40
05600		REREAD 11,RJ,RK,XK
05700		JMPR=0
05800		IF(XK.EQ.1)K='J'
05900	C  TYPE 3RD NUM=1 FOR JUMPS
05910		IF(XK.EQ.2)K='F'
05920	C  IF 3RD NUM=2 -- BEGIN FILL SECTION
06000	41	QJ=RJ
06100		QK=RK
06200		IF(REL)GO TO 141
06300	241	X=X+QJ*RSZ
06400		Y=Y+QK*RSZ
06500		NX=X
06600		NY=Y
06700		GO TO 48
06800	141	NX=GTPT(RJ,RJB)
06900		NY=GTPT(RK,CENTR)
07000		X=NX
07100		Y=NY
07200		GO TO 481
07300	40	KK=ZK
07400	C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
07500	C  F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
07600	C  Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
07700	C  D=EXTEND DRAWING,  F=START FILLER OUTLINE, SM=SMOOTH IT
07800	C  TYPE 'FX' TO FILL ORIGINAL OUTLINE AND EXIT.
07810	C  L,R,U,D + NUM  MOVES LAST POINT ENTERED.
07900		IF(ZK.NE.0)NZ=-1
08000	C  WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
08100		JMPR=0
08200		JCX=2
08300	C  JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
08400	C  FOR SHIFTS OF "JUMPS"
08500		IF(K.EQ.'B')GO TO 22
08600	CC	IF(K.EQ.'P')GO TO 56
08700		IF(K.EQ.'C')GO TO 51
08900		IF(K.EQ.'X')GO TO 3
09000		IF(K.EQ.' '.OR.K.EQ.'J'.OR.K.EQ.'Z')GO TO 47
09100		IF(K.EQ.'S')GO TO 79
09110		IF(K.EQ.'F')GO TO 47
09200	CC555	IF(K.NE.'N')GO TO 7
09205	C****** NO MORE 'N' OR 'P' ******
09210		IF(K.NE.'H')GO TO 7
09300	CC55	KK=NEXT
09400	CC	GO TO 52
09500	CC56	KK=NEXT-2
09600	52	IF(KK.LE.1)KK=2
09700		X=SCLEF(KK,1)
09800		Y=SCLEF(KK,2)
09900		NEXT=KK+1
10000		IF(KE)GO TO 48
10100		RX=X
10200		RY=Y
10202	58	IF(NEXT.GT.J+1)GO TO 44
10205		NN=JA-1
10210		CALL ITYP
10300		CALL EDTYP(K,X,Y,JJJ)
10600	C  TYPE "A" OR ":" TO ALTER
10800	C  TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
10850	C  , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
10900		IF(K.NE.'J')GO TO 573
10910	C  J=JUMP TO NEXT 'JUMP'
10920		DO 574 K=NEXT,J
10930	574	IF(MCLEF(K).GE.100000000)GO TO 575
10940	575	X=K-NEXT+1
10950		GO TO 82
11000	573	IF(K.NE.'B')GO TO 570
11020		X=-X
11040		GO TO 82
11100	570	IF(K.EQ.' '.AND.S)GO TO 81
11300		IF(K.EQ.'S')GO TO 82
11400	C  S=STEP AHEAD(N) (-N  OR B GOES BACK)
11500		IF(K.EQ.'X')GO TO 3
11510		IF(K.NE.'M'.AND.K.NE.'R')GO TO 572
11511	C  M OR R ALONE WILL MOVE LAST SET OF POINTS MOVED.  BUT BE CAREFUL!
11512		LL=0
11513		IF(X+Y.EQ.0)GO TO 580
11515		IF(X.OR.Y.EQ.0)GO TO 577
11517	C  "M  -N1, N2, N3" MOVES WHOLE BLOCKS (OR "M N1 0")
11518	C   OR USE 'R' FOR 'M' TO ROTATE GROUP OF POINTS
11519	C  TO SET ITEM # N2≠0,  SETS ITEM # TO N3 IF N3≠0.
11524		NY=Y-X+2
11526		NX=X+1
11530	576	MX=NX
11532		MY=NY
11535		IF(K.EQ.'R')MY=-MY
11537	580	NY=MY
11540		CALL SHIFT(MCLEF(MX),NY)
11550	C  TO MOVE SEGS MX THROUGH MY.
11555		CALL CLRPOG(1)
11560		CALL POG1
11570		CALL RDRAW(2,MCLEF(1),MCLEF)
11580		CALL DPYOUT(1)
11590		GO TO 58
11600	
11610	577	NX=ABS(X)
11620		IF(Y.NE.0)GO TO 578
11630		CALL UNPACK(NX,NX,NY,ITEM)
11640		GO TO 576
11650	578	NY=ABS(Y)
11660		IF(JJJ.NE.0)GO TO 579
11670		IK=IK+1
11680		TYPE 46,IK
11690		JJJ=IK
11700		IF(JJJ.GT.10)GO TO 58
11705	CC579	JB=NX
11707	579	LL=0
11715		NY=NY-NX+2
11716		NX=NX+1
11717		JB=NX
11718		CALL REPACK(JJJ,JB,NY,ITEM)
11720		GO TO 576
11730	
11900	572	MCLEF(1)=J
11950		IF(K.EQ.'F')GO TO 470
12000	C  TAKE OUT OTHER 'F'S IN DREDIT*****
12050	571	CALL DREDIT
12100	59	X=RX
12200		Y=RY
12300		KE=-1
12320		NX=0
12340		NY=0
12400		GO TO 170
12500	C  THIS WRECKS "CLOSE"
12510	470	MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
12520		K='X'
12530		GO TO 34
12600	47	IF(REL.EQ.0)GO TO 22
12700	C  IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
12800		CALL RDCUR(NX,NY)
12900		X=NX
13000		Y=NY
13100		IF((K.NE.'Z'.AND.NZ).OR.K.EQ.'J'.OR.K.EQ.'F')GO TO 48
13200		NZ=0
13300		DO 54 K=JCX,JCL
13400	      IF(ABS(SCLEF(K,1)-X).GT.RN.OR.ABS(SCLEF(K,2)-Y).GT.RN)
13500		1 GO TO 54
13600		KK=K
13700		GO TO 52
13800	54	CONTINUE
13900		IF(KE)GO TO 48
13950	C  KE=-1  = DRAW MODE (NOT EDIT)
14000		TYPE 154
14100		GO TO 4
14200	154	FORMAT(' NO POINT FOUND ')
14400	C  ABOVE FOR INITIAL MOVEMENT OF CURSOR
14500	51	X=RX
14600		Y=RY
14700	48	RJ=STPT(X,RJB)
14800		RK=STPT(Y,CENTR)
14900	481	SK=RK
15000		J=J+1
15100	551	SJ=RJ
15200	C  DO I NEED RJ,RK ANYWHERE??  YES - AT REPACK
15300	451	LL=0
15400		IF(K.EQ.'J')LL=100000000
15500	C  J=JUMP
15510		IF(K.NE.'F')GO TO 452
15515		K='J'
15555	253	LL=200000000
15600	452	IJ=RJ
15700		IK=RK
15900		JCL=J
16000		CALL REPACK(J,IJ,IK,MCLEF)
16100		IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
16200	61	J=J-1
16300		GO TO 4
16400	60	SCLEF(J,1)=X
16500		SCLEF(J,2)=Y
16900	50	N=IST(2)
17000		X=GTPT(SJ,RJB)
17100		Y=GTPT(SK,CENTR)
17200		NX=X
17300		NY=Y
17400		IF(K.EQ.'B')GO TO 5
17500		IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
17600		CALL AVECT(NX,NY)
17700		GO TO 5
17800	6	CALL AIVECT(NX,NY)
17900		JX=-1
18000		JMPR=-1
18200	C  KZ IS FOR "CLOSE IT"
18300		NZ=-1
18400		RX=X
18500		RY=Y
18600	5	CALL DPYOUT(1)
18650		L=J-1
18700		TYPE 46,L,SJ,SK
18800	
18900	170	CALL SETCUR(NX,NY,JC)
19000		GO TO 4
19020	74	FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
19100	7	IF(K.NE.'E')GO TO 71
19200	C  E=EDIT 
19240	700	TYPE 74
19250		ACCEPT 1,K,X
19260		IF(K.NE.'L')GO TO 79
19300		IF(ZK.NE.0)JCX=ZK
19400	C  SETS "ZEROING-IN" FIRST COUNTER
19500		NZ=0
19600		KE=0
19610	C  EDIT FLAG  KE=0
19700		TYPE 70
19800		GO TO 44
19900	70	FORMAT(' CHOOSE A POINT ')
20600	71	IF(ZK.EQ.0)ZK=1
20700		IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
20900		IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
21000		SK=ZK+SK
21100		Y=GTPT(SK,CENTR)
21200		GO TO 78
21300	77	SJ=ZK+SJ
21400		X=GTPT(SJ,RJB)
21500	78	CALL BUP
21600		J=J-1
21800		GO TO 48
21900	79	S=-1
22000		JA=ZK-1
22100	84	IF(JA.LT.2)JA=1
22200	81	IF(K.NE.'D')JA=JA+1
22250		IF(JA.GT.J)JA=J
22300		X=SCLEF(JA,1)
22400		Y=SCLEF(JA,2)
22500		NX=X
22600		NY=Y
22700		NEXT=JA+1
22800		CALL SETCUR(NX,NY,0)
22900		GO TO 58
23000	82	IF(X.EQ.0)X=-1
23100		JA=JA-1+X
23200		GO TO 84
23300	22	IF(J.EQ.JZ)GO TO 4
23400	C  CAN'T BACKUP PAST 1 OR 'F'
23500		J=J-1
23900	122	CALL UNPACK(J,IJ,IK,MCLEF)
24000		CALL BUP
24100		SJ=IJ
24200		SK=IK
24500		IF(K.EQ.'B')GO TO 50
24600		RJ=RJ+QJ
24700		RK=RK+QK
24800		GO TO 241
25000	3	MCLEF(1)=J
25100		IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
25500	34	CALL CLRCUR
25700		IF(K.NE.'X')GO TO 120
27100	1	FORMAT(A1,2F)
27200	11	FORMAT(3F)
27300	46	FORMAT(I3,'.)',2F6.0/)
27500		END